perm filename EULER[GEM,BGB]1 blob
sn#030934 filedate 1973-03-27 generic text, type T, neo UTF8
00100 TITLE EULER - EULER PRIMITIVES - JULY 1972.
00200
00300 COMMENT /
00400 These primitives preserve the Euler Equation F-E+V = 2*B-2*H;
00500
00600 INVERT(E); "|" COMMAND.
00700 EVERT(B); "¬" COMMAND.
00800 VNEW ← MKEV(F,V); "E" COMMAND.
00900 ENEW ← MKFE(V1,F,V2); "J" COMMAND.
01000 VNEW ← ESPLIT(E); "M" COMMAND.
01100 F ← KLFE(ENEW); "K" COMMAND.
01200 E ← KLEV(VNEW); "K" COMMAND.
01300 V ← KLVE(ENEW); "αK" COMMAND.
01400 BNEW ← MKCOPY(B); "C" COMMAND.
01500 ENEW ← GLUEE(F1,V1,F2,V2); "J" COMMAND.
01600 /
01700
01800 ;THE EULER PRIMITVES ARE DEPENDENT ON THE WING OPERATIONS.
01900 EXTERN MKNODE,KLNODE
02000 EXTERN MKB,MKF,MKE,MKV
02100 EXTERN KLB,KLF,KLE,KLV,WING
02200 EXTERN WING,LINKED
02300 EXTERN ECW,ECCW,OTHER,OTHER.
02400 EXTERN BGET,FCW,FCCW,VCW,VCCW
02450 EXTERN BATT,BDET
02500
02600 ;BIT FOR MARKING EDGES OF A WASP FACE'S WAIST.
02700 ↓WASP←←1B5
00100 SUBR(INVERT)------------------------------------------------------
00200 BEGIN INVERT
00300 LAC 1,ARG1
00400 MOVSS 1(1)↔MOVSS 3(1)↔MOVSS 4(1)↔MOVSS 5(1)
00500 MOVNS -3(1)↔MOVNS -2(1)↔MOVNS -1(1)
00600 POP1J
00700 BEND;1/14/73------------------------------------------------------
00800
00900 ;EVERT(B) - TURN BODY INSIDE OUT.
01000 SUBR(EVERT)BODY --------------------------------------------------
01100 BEGIN EVERT; TURN SOMETHING INSIDE OUT.
01200 ACCUMULATORS{B,E}
01300 CDR B,ARG1
01400 TEST B,BBIT↔POP1J
01500 LAC E,B
01600 L1: PED E,E
01700 TEST E,EBIT↔GO L3
01800 MOVSS 1(E)
01900 MOVS 4(E)↔MOVS 1,5(E)
02000 DAC 1,4(E)↔DAC 5(E)
02100 GO L1
02200
02300 ;PARTS OF THIS BODY.
02400 L3: SON 1,B↔JUMPE 1,POP1J.
02500 L4: PUSH P,1↔CALL(EVERT,1)
02700 POP P,1↔LAC B,ARG1
02800 BRO 1,1↔SON 0,B
02900 CAME 0,1↔GO L4↔POP1J
03000 BEND;1/14/73------------------------------------------------------
00100 ;VNEW ← MKEV(F,V). "E" COMMAND.
00200 SUBR(MKEV)--------------------------------------------------------
00300 BEGIN MKEV
00400 ACCUMULATORS {VNEW,B,F,V,ENEW,E1,E2}
00500
00600 ;CHECK FOR BAD ARGUMENTS.
00700 CDR VNEW,ARG1;FOR BAD RETURNS.
00800 LAC V,ARG1↔TEST(V,VBIT)↔POP2J
00900 LAC F,ARG2↔TEST(F,FBIT)↔POP2J
01000
01100 ;CREATE A NEW EDGE AND VERTEX.
01200 SETQ(B,{BGET,V})
01300 SETQ(VNEW,{MKV,B})
01400 SLACI XWC(V)↔LAPI XWC(VNEW)↔BLT ZWC(VNEW)
01450 LAC 1(V)↔DAC 1(VNEW)
01500 SETQ(ENEW,{MKE,B})
01600
01700 ;MAKE FACE AND VERTEX LINKS.
01800 PED. ENEW,VNEW
01900 NFACE. F,ENEW
02000 PFACE. F,ENEW
02100 NVT. VNEW,ENEW
02200 PVT. V,ENEW
02300
02400 ;CHECK FOR VERTEX BODY CASE.
02500 PED E1,F↔JUMPE E1,[
02600 PED. ENEW,F↔PED. ENEW,V
02700 PCW. ENEW,ENEW↔NCCW. ENEW,ENEW↔GO .+1]
02800
02900 ;LOWER WINGS POINT AT SELF.
03000 NCW. ENEW,ENEW
03100 PCCW. ENEW,ENEW
03200
03300 ;GET THE UPPER WINGS.
03400 PED E1,V↔LAC E2,E1
03500 NFACE 0,E1↔PFACE 1,E1
03600 CAMN 0,1↔GO L2
03700 L1: LAC E1,E2
03800 SETQ(E2,{ECW,E1,V})
03900 CALL(FCW,E1,V)
04000 CAME 1,F↔GO L1
04100
04200 ;TIE ENEW TO ITS UPPER WINGS.
04300 L2: PCW. E1,ENEW↔NCCW. E2,ENEW
04400 PVT 0,E1↔CAME 0,V↔GO[PCCW. ENEW,E1↔GO .+2]↔NCCW. ENEW,E1
04500 PVT 0,E2↔CAME 0,V↔GO[NCW. ENEW,E2↔GO .+2]↔PCW. ENEW,E2
04600 LAC 1,VNEW↔POP2J
04700 LIT
04800 BEND;1/14/73------------------------------------------------------
00100 ;ENEW ← MKFE(V1,F,V2); "J" COMMAND.
00200 SUBR(MKFE)--------------------------------------------------------
00300 BEGIN MKFE
00400 ACCUMULATORS{V1,F,V2,FNEW,ENEW,E,E0,B,V}
00500
00600 ;FETCH THE ARGUMENTS.
00700 CDR V1,ARG3
00800 CDR F,ARG2
00900 CDR V2,ARG1
01000
01100 ;DO THE CREATIONS.
01200 SETQ(B,{BGET,F})
01300 SETQ(FNEW,{MKF,B})
01400 SETQ(ENEW,{MKE,B})
01500
01600 ;LINK ENEW.
01700 PED. ENEW,F↔ PED. ENEW,FNEW
01800 PFACE. F,ENEW↔ NFACE. FNEW,ENEW
01900 PVT. V1,ENEW↔ NVT. V2,ENEW
02000
02100 ;GET THE UPPER WINGS.
02200 PED E,V1↔LAC E0,E↔MOVS 1(E)↔CAME 1(E)
02300 GO[L1: LAC E0,E↔ SETQ(E,{ECW,E0,V1})
02400 CALL(FCW,E0,V1)↔CAME 1,F↔GO L1↔GO .+1]
02500 DAC E0,E1#↔DAC E,E2#
02600
02700 ;GET THE LOWER WINGS.
02800 PED E,V2↔LAC E0,E↔MOVS 1(E)↔CAME 1(E)
02900 GO[L2: LAC E0,E↔ SETQ(E,{ECW,E0,V2})
03000 CALL(FCW,E0,V2)↔CAME 1,F↔GO L2↔GO .+1]
03100 DAC E0,E3#↔DAC E,E4#
03200
03300 COMMENT . MKFE MANDALA
03400 o--------o o--------o
03500 | E2 \ / E1 |
03600 | nccw \ / pcw |
03700 | \ / |
03800 | pvt ⊗ V1 |
03900 | | |
04000 | FNEW ENEW F |
04100 | | |
04200 | nvt ⊗ V2 |
04300 | / \ |
04400 | ncw / \ pccw |
04500 | E3 / \ E4 |
04600 o--------o o--------o
04700
04800 -----------------------------------------------------------------.
00100 ;CDR V2'S TAIL REPLACING F'S WITH FNEW.
00200 LAC E,E3↔LAC V,V2
00300 L3: MOVS 1,1(E)↔CAME 1,1(E)↔GO L4
00400 PFACE. FNEW,E
00450 SETQ(V,{OTHER,E,V})
00500 SETQ(E,{ECCW,E,V})↔GO L3
00600
00700 ;CCW FROM V1 REPLACING F'S WITH FNEW.
00800 L4: LAC E0,E↔LAC E,E2↔SETZM A#↔CAMN E0,E2↔GO L6
00900 L5: TESTZ E,WASP↔JSR WASPS
01000 NFACE 0,E
01100 CAME F,0
01200 GO[PFACE. FNEW,E↔GO .+2]
01300 NFACE. FNEW,E
01400 CAME E,E0
01500 GO[DAC E,A↔SETQ(E,{ECCW,E,FNEW})↔GO L5]
01600
01700 ;LINK THE WINGS.
01800 L6: CALL(WING,E1,ENEW)
01900 CALL(WING,E2,ENEW)
02000 CALL(WING,E3,ENEW)
02100 CALL(WING,E4,ENEW)
02200 L7: LAC 1,ENEW↔POP3J
02300
02400 WASPS: 0
02500
02600 PCW 1,E↔CAMN 1,A↔GO W1
02700 PCCW 1,E↔CAME 1,A↔GO W2
02800
02900 W1: SETZM A↔MARKZ E,WASP
03000 PFACE. FNEW,E↔SETQ(E,{ECCW,E,FNEW})
03100 TESTZ E,WASP↔GO W1↔GO @WASPS
03200
03300 W2: SETZM A↔MARKZ E,WASP
03400 NFACE. FNEW,E↔SETQ(E,{ECCW,E,FNEW})
03500 TESTZ E,WASP↔GO W2↔GO @WASPS
03600
03700 LIT
03800 BEND;1/14/73------------------------------------------------------
00100 ;VNEW ← ESPLIT(E); "M" COMMAND.
00200 SUBR(ESPLIT)------------------------------------------------------
00300 BEGIN ESPLIT
00400 ACCUMULATORS{VNEW,ENEW,B,E,V}
00500
00600 ;CHECK FOR BAD ARGUMENTS.
00700 CDR VNEW,ARG1
00800 LAC E,VNEW
00900 TEST E,EBIT↔GO L1
01000 PVT V,E
01100
01200 ;CREATE A NEW EDGE AND VERTEX.
01300 CCW B,E
01400 SETQ(VNEW,{MKV,B})
01500 SETQ(ENEW,{MKE,B})
01600 SLACI AA(E)↔LAPI AA(ENEW)↔BLT CC(ENEW)
01700
01800 ;PLACE VNEW BETWEEN E AND ENEW.
01900 PED 0,V↔CAMN 0,E↔PED. ENEW,V
02000 PED. ENEW,VNEW
02100 PVT 0,E↔PVT. 0,ENEW
02200 PVT. VNEW,E
02300 NVT. VNEW,ENEW
02400 PFACE 0,E↔PFACE. 0,ENEW
02500 NFACE 0,E↔NFACE. 0,ENEW
02600
02700 ;NEW UPPER WINGS ARE LIKE THE OLDE;
02800 PCW 0,E↔CALL(WING,0,ENEW)
02900 NCCW 0,E↔CALL(WING,0,ENEW)
03000
03100 ;EDGES POINT AT EACH OTHER ACROSS VNEW.
03200 NCCW. ENEW,E↔PCW. ENEW,E
03300 NCW. E,ENEW↔PCCW. E,ENEW
03400 L1: LAC 1,VNEW↔POP1J
03500
03600 BEND;1/14/73------------------------------------------------------
00100 ;F ← KLFE(ENEW); "K" COMMAND.
00200 SUBR(KLFE)--------------------------------------------------------
00300 BEGIN KLFE
00400 ACCUMULATORS{ENEW,FNEW,V1,V2,E1,E2,E3,E4,E,F,B}
00500
00600 ;PICK THINGS UP.
00700 CDR ENEW,ARG1
00800 PFACE F,ENEW↔ NFACE FNEW,ENEW
00900 PVT V1,ENEW↔ NVT V2,ENEW
01000
01100 ;GET THE WINGS.
01200 PCW E1,ENEW
01300 NCCW E2,ENEW
01400 NCW E3,ENEW
01500 PCCW E4,ENEW
01600
01700 ;GET RID OF ENEW APPEARANCES IN F & V.
01800 PED 0,V1↔ CAMN 0,ENEW↔ PED. E1,V1
01900 PED 0,V2↔ CAMN 0,ENEW↔ PED. E3,V2
02000 PED 0,F ↔ CAMN 0,ENEW↔ PED. E3,F
02100
02200 ;GET RID OF FNEW APPEARANCES
02300 LAC E,E2
02400 L1: PFACE 0,E↔CAMN 0,FNEW↔GO[PFACE. F,E↔GO L2]
02500 NFACE 0,E↔CAMN 0,FNEW↔GO[NFACE. F,E↔GO L2]
02600 FATAL(KLFE)
02700 L2: CAME E,E3↔GO[SETQ(E,{ECCW,E,F})↔GO L1]
02800
02900 ;LINK WINGS TOGETHER ABOUT F.
03000 CALL(WING,E2,E1)
03100 CALL(WING,E4,E3)
03200
03300 ;GET RID OF FNEW AND ENEW.
03400 CCW B,ENEW
03500 CALL(KLF,B,FNEW)
03600 CALL(KLE,B,ENEW)
03700 LAC 1,F↔POP1J
03800
03900 BEND;1/14/73------------------------------------------------------
00100 ;E ← KLEV(VNEW); "K" COMMAND.
00200 SUBR(KLEV)--------------------------------------------------------
00300 BEGIN KLEV
00400 ACCUMULATORS{E,ENEW,V,VNEW,F,B}
00500 CDR VNEW,ARG1↔PED ENEW,VNEW
00600 SETQ(E,{ECCW,ENEW,VNEW})
00700 CAMN E,ENEW↔GO[SETQ(V,{OTHER,ENEW,VNEW}) ;EAT WIRE.
00800 SETQ(E,{ECCW,ENEW,V})↔NCW. E,E↔PCCW. E,E↔GO L1]
00900 CALL(ECCW,E,VNEW)↔CAME 1,ENEW
01000 GO[CALL(KLFE,1)↔GO KLEV]
01100
01200 ;ORIENT EDGES AS IN MANDALA.
01300 NVT 0,ENEW↔CAMN 0,VNEW↔GO .+3↔CALL(INVERT,ENEW)
01400 PVT 0,E↔CAMN 0,VNEW↔GO .+3↔CALL(INVERT,E)
01500 ;TIE E TO ITS NEW VERTEX.
01600 PVT V,ENEW↔ PVT. V,E
01700 ;MAKE E'S UPPER WINGS LIKE ENEW'S.
01800 PCW 0,ENEW↔CALL(WING,0,E)
01900 NCCW 0,ENEW↔CALL(WING,0,E)
02000
02100 ;ELIMINATE OCCURENCES OF ENEW IN F & V.
02200 L1: PED 0,V↔ CAMN 0,ENEW↔ PED. E,V
02300 PFACE F,E↔ PED 0,F↔ CAMN 0,ENEW↔ PED. E,F
02400 NFACE F,E↔ PED 0,F↔ CAMN 0,ENEW↔ PED. E,F
02500 ;PURGE 'EM.
02600 CCW B,ENEW
02700 CALL(KLV,B,VNEW)
02800 CALL(KLE,B,ENEW)
02900 LAC 1,E↔SLAC 1(1)↔CAMN 1(1)↔NVT 1,1
02950 POP1J↔LIT
03000 COMMENT . \ pvt / KLEV MANDALA
03100 \ /
03200 nccw \ / pcw
03300 \ /
03400 V ⊗
03500 |
03600 ENEW |
03700 | nvt
03800 VNEW ⊗
03900 | pvt
04000 E |
04100 |
04200 ⊗
04300 / \
04400 ncw / \ pccw
04500 / \
04600 / nvt \ .
04700 BEND;1/14/73------------------------------------------------------
00100 ; V ← KLVE(E) - KILL E & NVT(E) RETURNING PVT(E).
00200 SUBR(KLVE)--------------------------------------------------------
00300 BEGIN KLVE
00400 ACCUMULATORS{A,E,E1,E2,E3,E4,V1,V2,S12}
00500
00600 ;PICK THINGS UP.
00700 CDR E,ARG1↔NVT V1,E↔PVT V2,E
00800 PCW E1,E↔NCCW E2,E↔NCW E3,E↔PCCW E4,E
00900
01000 ;REPLACE FACE-VERTEX PED'S THAT MIGHT CONTAIN E.
01100 PFACE 1,E↔PED 0,1↔CAMN 0,E↔PED. E1,1
01200 NFACE 1,E↔PED 0,1↔CAMN 0,E↔PED. E2,1
01300 PED 0,V2↔CAMN 0,E↔PED. E2,V2
01400
01500 ;REPLACE V1 WITH V2.
01600 LAC A,E3
01700 L1: PVT 1,A↔CAME 1,V1↔GO[NVT. V2,A↔GO .+2]↔PVT. V2,A
01800 SETQ(A,{ECCW,A,V2})
01900 CAME A,E↔GO L1
02000
02100 ;SPLICE WINGS TOGETHER.
02200 CALL(WING,E1,E4)
02300 CALL(WING,E2,E3)
02400
02500 ;BURN THE GARBAGE.
02600 CCW A,E
02700 CALL(KLE,A,E)
02800 CALL(KLV,A,V1)
02900 LAC 1,V2
03000 POP1J
03100 LIT
03200 BEND;1/14/73------------------------------------------------------
03300 COMMENT . KLVE MANDALA
03400 E2 \ / E1
03500 nccw \ / pcw
03600 \ /
03700 pvt ⊗ V2
03800 |
03900 | E
04000 |
04100 nvt ⊗ V1
04200 / \
04300 ncw / \ pccw
04400 E3 / \ E4.
00100 ;BNEW ← MKCOPY(B).
00200 SUBR(MKCOPY)------------------------------------------------------
00300 BEGIN MKCOPY
00400 ACCUMULATORS{B,F,E,V,BNEW,Q,A}
00500 EXTERN MKFRAME
00600 LAC B,ARG1↔LACM 1,(B)↔SKIPE 1↔TLNE 1,(1B9)↔GO[
00800 CALL(MKNODE,[0])↔SLACI XWC(B)↔LAPI XWC(1)↔BLT KZ(1)↔POP1J]
01000 TEST B,BBIT↔POP1J↔SETQ(BNEW,{MKB,B})
01100 FRAME Q,B↔SKIPE Q↔GO[CALL(MKFRAME)↔FRAME. 1,BNEW
01200 SLACI XWC(Q)↔LAPI XWC(1)↔BLT KZ(1)↔GO .+1]
01300 LAC B,ARG1↔LAC F,B↔LAC E,B↔LAC V,B
01400
01500 ;FOR ALL THE EDGES OF THE BODY.
01600 L1: PED E,E↔TEST E,EBIT↔GO L2
01700 SETQ(Q,{MKE,BNEW})↔ALT. Q,E↔GO L1
01800
01900 ;FOR ALL THE FACES OF THE BODY.
02000 L2: PFACE F,F↔TEST F,FBIT↔GO L3
02100 SETQ(Q,{MKF,BNEW})↔ALT. Q,F
02200 PED A,F↔ALT A,A↔PED. A,Q
02300 LAC QQ(F)↔DAC QQ(Q)↔GO L2
02400
02500 ;FOR ALL THE VERTICES OF THE BODY.
02600 L3: PVT V,V↔TEST V,VBIT↔GO L4
02700 SETQ(Q,{MKV,BNEW})↔ALT. Q,V
02800 PED A,V↔ALT A,A↔PED. A,Q
02900 SLACI XWC(V)↔LAPI XWC(Q)↔BLT ZWC(Q)↔GO L3
03000
03100 ;FOR ALL THE EDGES OF THE BODY.
03200 L4: PED E,E↔TEST E,EBIT↔GO L5
03300 ALT Q,E
03400 PVT V,E↔ ALT V,V↔PVT. V,Q
03500 NVT V,E↔ ALT V,V↔NVT. V,Q
03600 PFACE F,E↔ALT F,F↔PFACE. F,Q
03700 NFACE F,E↔ALT F,F↔NFACE. F,Q
03800 NCW A,E↔ ALT A,A↔NCW. A,Q
03900 PCW A,E↔ ALT A,A↔PCW. A,Q
04000 NCCW A,E↔ ALT A,A↔NCCW. A,Q
04100 PCCW A,E↔ ALT A,A↔PCCW. A,Q↔GO L4
00100 L5: SETZ↔LAC 1,BNEW↔SKIPA E,ARG1
00200 L6: ALT. 0,E↔PED E,E↔CAME E,ARG1↔GO L6
00300 ;PARTS OF THIS BODY.
00400 LAC B,ARG1↔TESTZ B,BDPBIT↔POP1J
00500 SON Q,B↔JUMPE Q,POP1J.
00600 L7: PUSH P,Q↔PUSH P,BNEW↔CALL(MKCOPY,Q)
00800 LAC BNEW,(P)↔CALL(BATT,1,BNEW)
00900 POP P,BNEW↔POP P,Q↔LAC B,ARG1
01000 BRO Q,Q↔SON 0,B↔CAME 0,Q↔GO L7
01100 LAC 1,BNEW↔POP1J
01200 BEND;1/14/73------------------------------------------------------
00100 ;ENEW ← GLUEE(F1,V1,F2,V2) - LIKE TWO MKEV(F,V)'S BACK TO BACK.
00200 SUBR(GLUEE)-------------------------------------------------------
00300 BEGIN GLUEE
00400 Q←1
00500 ACCUMULATORS{F1,V1,F2,V2,B,E,E1,E2,E3,E4}
00600 CDR F1,ARG4↔CDR V1,ARG3
00700 CDR F2,ARG2↔CDR V2,ARG1
00800 ;BODY SPLICING.
00900 PED E,F1↔CCW B,E
01000 PED E,F2
01100
01200 ;REPLACE F2 WITH F1.
01300 PED E,F2↔DAC E,E0#
01400 L1: PFACE Q,E↔CAMN Q,F2↔PFACE. F1,E
01500 NFACE Q,E↔CAMN Q,F2↔NFACE. F1,E
01600 SETQ(E,{ECCW,E,F1})
01700 CAME E,E0↔GO L1
01800 CALL(KLF,B,F2)
01900
00100 COMMENT . GLUEE MANDALA
00200
00300 | | |
00400 | +V2 |
00500 | / | \ |
00505 | / | \ |
00600 NCCW | E2/ | \E1 | PCW
00606 | / | \ |
00700 | / F2 | F2 \ |
00800 o______ | ______o
00900 | HOWEVER,
01000 WASP | ENEW GLUEE RETURN'S ENEW INVERTED
01100 o______ | ______o
01200 |\ | /|
01300 | \ F1 | F1 / |
01400 | \ | / |
01500 NCW | E3\ | /E4 | PCCW
01600 | \ | / |
01700 | \ | / |
01800 | -V1 |
01900 | | |
02000 | | | .
02100 ;EDGE CREATION
02200 SETQ(E,{MKE,B})
02300 MARK E,WASP
02400 NFACE. F1,E↔PFACE. F1,E
02500 NVT. V1,E↔PVT. V2,E
02600
02700 ;MAKE WINGS
02800 SETQ(E1,{ECW,V2,F1})↔PCW. E1,E
02900 SETQ(E2,{ECW,E1,V2})↔NCCW. E2,E
03000 SETQ(E3,{ECW,V1,F1})↔NCW. E3,E
03100 SETQ(E4,{ECW,E3,V1})↔PCCW. E4,E
03200
03300 PVT Q,E1↔CAME Q,V2↔GO[PCCW. E,E1↔GO .+2]↔NCCW. E,E1
03400 PVT Q,E2↔CAME Q,V2↔GO[NCW. E,E2↔GO .+2]↔PCW. E,E2
03500 PVT Q,E3↔CAME Q,V1↔GO[PCCW. E,E3↔GO .+2]↔NCCW. E,E3
03600 PVT Q,E4↔CAME Q,V1↔GO[NCW. E,E4↔GO .+2]↔PCW. E,E4
03700
03800 ;MARK WASP WAIST ON POTENTIAL SPUR STARTING AT V1.
03900 CAME E1,E2↔GO L2
04000 MARK E1,WASP↔PVT V1,E1↔PED E1,V1
04100 MOVS Q,1(E1)↔CAMN Q,1(E1)↔GO .-5
04200
04300 L2: LAC Q,E↔CALL(INVERT,Q)↔POP4J
04400 LIT
04500 BEND;1/14/73------------------------------------------------------
00100 SUBR(GLUE)F1,F2---------------------------------------------------
00200 BEGIN GLUEFF;GLUE TWO FACES TOGETHER - BGB 10 FEBRUARY 1973.
00300 EXTERN DISTAN
00400 ;ARGUMENTS MUST BE FACES WITH THE SAME NUMBER OF VERTICES.
00500 LAC 1,ARG1↔DAC 1,F1↔TEST 1,FBIT↔POP2J
00600 LAC 1,ARG2↔DAC 1,F2↔TEST 1,FBIT↔POP2J
00700 LAC 1,F1↔PED 2,1↔DAC 2,E↔DAC 2,E0↔LACI 10,1
00800 L1: SETQ(E,{ECCW,E,F1})↔CAME 1,E0↔AOJA 10,L1↔DAC 10,NN
00900 LAC 1,F2↔PED 2,1↔DAC 2,E↔DAC 2,E0↔SOS 10
01000 L2: SETQ(E,{ECCW,E,F2})↔CAME 1,E0↔SOJA 10,L2↔SKIPE 10↔POP2J
01100
01200 ;FIND V2 CLOSEST TO V1.
01300 LAC 1,F1↔PED 2,1↔SETQ(V1,{VCW,2,1})
01400 HRLOI 377777↔DAC MIN
01500 SETZM LIST1↔SETZM LIST2
01600 L3: SETQ(V,{VCW,E,F2})
01700 CALL(DISTAN,V,V1)
01800 CAMGE 1,MIN↔GO[DAC 1,MIN↔LAC V↔DAC V2↔GO .+1]
01900 LAC 1,E↔LAC LIST1↔DAP -1(1)↔DAC 1,LIST1
02000 LAC 1,V↔LAC LIST2↔DAP -1(1)↔DAC 1,LIST2
02100 SETQ(E,{ECCW,E,F2})
02200 CAME 1,E0↔GO L3
02300 CALL(GLUEE,F1,V1,F2,V2)
02400 CALL(INVERT,1)
02500
02600 ;CLOSE UP THE GAP.
02700 SOS NN
02800 L4: PCCW 0,1↔PUSH P,0↔PCW 0,1↔PUSH P,0
02900 SETQ(V2,{OTHER,V2})↔SETQ(V1,{OTHER,V1})
03000 CALL(MKFE,V2,F1,V1)↔SOSLE NN↔GO L4
03100
03200 ;NOW KILL ALL THOSE EDGES.
03300 L5: SKIPN 1,LIST1↔GO L6↔CDR 0,-1(1)↔DAC 0,LIST1
03400 CALL(KLFE,1)↔GO L5
03500 L6: SKIPN 1,LIST2↔GO L7↔CDR 0,-1(1)↔DAC 0,LIST2
03600 CALL(KLEV,1)↔GO L6
03700
03800 L7: LAC 1,F1↔PED 1,1↔CCW 1,1
03900 POP2J
04000 DECLARE{F1,F2,V,V1,V2,NN,E,E0,MIN,LIST1,LIST2}
04100 BEND;2/10/73------------------------------------------------------
00100 SUBR(SWEEP)FACE,FLAG----------------------------------------------
00200 BEGIN SWEEP
00300
00400 ;TEST FOR VALID ARGUMENT.
00500 LAC 1,ARG2↔DAC 1,F↔TEST 1,FBIT↔POP2J
00600 PED 2,1↔DAC 2,E↔SKIPN 2↔POP2J
00700 TEST 2,EBIT↔POP2J
00800
00900 ;TEST FOR SPECIAL CASES.
01000 PCW 3,2↔CAMN 3,2↔GO SWEEP2 ;WIRE SWEEP CASE.
01100 SETZM E0↔NCNT 0,1↔DACM NN
01200 SKIPE↔SETZM ARG1
01300
01400 ;MAKE FIRST SPOKE.
01500 CALL(VCW,E,F)↔DAC 1,U0↔DAC 1,U1
01600 CALL(MKEV,F,U0)↔DAC 1,V0↔DAC 1,V1
01700
01800 ;COPY FACE PERIMETER LOOP.
01900 L1: SETQ(U2,{VCCW,E,F}) ;ADVANCE ALONG RIM.
02000 SETQ(E,{ECCW,E,F})
02100 LAC 1,U2↔CAME 1,U0 ;MAKE NEXT SPOKE.
02200 GO[CALL(MKEV,F,U2)↔GO .+2]
02300 LAC 1,V0↔DAC 1,V2
02400 CALL(MKFE,V1,F,V2) ;CONNECT SPOKES.
02500 SKIPN E0↔DAC 1,E0 ;NEW FIRST EDGE.
02600
02700 ;SPLIT NEW FACE TO MAKE PRISMOIDS.
02800 NFACE 0,1
02900 SKIPGE ARG1↔GO[CALL(MKFE,V1,0,U2)↔GO .+3] ;CW -1.
03000 SKIPLE ARG1↔GO[CALL(MKFE,U1,0,V2)↔GO .+1] ;CCW +1.
03100
03200 ;TEST FOR END OF COPY LOOP.
03300 LAC V2↔DAC V1
03400 LAC U2↔DAC U1
03500 SOSN NN↔GO .+3
03600 CAME U0↔GO L1 ;EXIT WHEN NN=0 OR U2=U0
03700 ;EXIT.
03800 LAC 0,E0↔LAC 1,F
03900 PED. 0,1↔POP2J
04000
04100 DECLARE{F,E,E0,U0,U1,U2,V0,V1,V2,NN}
04200 COMMENT . U2 o----------o U1 FACE SWEEP MANDALA
04300 / \ / \
04400 / \ FNEW / \
04500 / \____/ \
04600 / v2 v1 \
04700 / F \.
04800 BEND;2/7/73-------------------------------------------------------
00100 SWEEP2:;FACE,FLAG-------------------------------------------------
00200 BEGIN SWEEP2;WIRE FACE SWEEP - BGB - 7 FEB 1973.
00300
00400 ;COUNT THE EDGES IN THE WIRE.
00500 LAC 3,ARG2↔DAC 3,FACE ;FACE
00600 PED 1,3↔LACI 0,1 ;EDGE & NCNT.
00700 LAC 2,1↔NCW 1,1
00800 CAME 1,2↔AOJA 0,.-3 ;COUNT THE EDGES.
00900
01000 ;MAKE "BOTTOM" EDGE.
01100 DAC 1,E ;LAST EDGE.
01200 NCNT. 0,3↔DAC NN
01300 NVT 1,1 ;LAST VERTEX OF THE WIRE.
01400 SETQ(V2,{MKEV,FACE,1}) ;BOTTOM EDGE.
01500
01600 ;COPY THE WIRE.
01700 L1: SETQ(V2,{MKEV,FACE,V2})
01800 LAC 3,E↔PVT 2,3↔DAC 2,V1
01900 SLACI XWC(2)↔LAPI XWC(1)↔BLT ZWC(1)
02000 PCW 2,3↔DAC 2,E↔CAME 2,3↔GO L1
02100
02200 ;CLOSE THE TOP.
02300 SETQ(E,{MKFE,V1,FACE,V2})
02400 NFACE 1,1↔DAC 1,FNEW
02500 SOSG NN↔GO L3
02600
02700 ;FOLLOW DOWN BOTH SIDES.
02800 L2: CALL(ECCW,E,FNEW)↔SETQ(V1,{OTHER,1,V1})
02900 CALL(ECW,E,FNEW)↔SETQ(V2,{OTHER,1,V2})
03000 SETQ(E,{MKFE,V2,FNEW,V1})
03100 SOSLE NN↔GO L2
03200
03300 ;UPDATE THE FIRST EDGE OF THE FACE.
03400 L3: LAC 2,ARG2↔PED 1,2
03500 CALL(ECCW,1,2)↔PED. 1,2
03600 LAC 1,2↔POP2J
03700
03800 COMMENT . ⊗ ⊗-------⊗ ⊗-------⊗
03900 + | | | | |
04000 PED(F) | | | | |PED(F)'
04100 - | | | | |
04200 ⊗ ⊗ ⊗ V1→ ⊗-------⊗ ←V2
04300 + | | | | |
04400 | | FNEW | F below | |
04500 - | | | | |
04600 ⊗ ⊗ ⊗ ⊗ FNEW ⊗
04700 + | | | | |
04800 | | | | |
04900 - | | | | |
05000 ⊗ ⊗-------⊗ ⊗-------⊗ .
05100 DECLARE{FACE,FNEW,NN,V1,V2,E}
05200 BEND;2/7/73-------------------------------------------------------
00100 SUBR(ROTCOM)FACE--------------------------------------------------
00200 BEGIN ROTCOM;SOLID OF ROTATION COMLETION - BGB -8 FEB 1973.
00300 ACCUMULATORS{F,E,E0,M,N}
00400 LAC F,ARG1↔DAC F,FACE↔TEST F,FBIT↔POP1J
00500 NCNT N,F↔DACM N,NN↔SKIPN↔POP1J
00600
00700 ;COUNT THE EDGES IN THIS FACE.
00800 LACI M,1↔PED E,F↔DAC E,E0↔DAC E,EDGE
00900 L1: SETQ(E,{ECCW,E,F})
01000 CAME E,E0↔AOJA M,L1
01100
01200 ;SKIP AROUND THE NORTH POLE CAP.
01300 ASH M,-1↔SUB M,NN
01400 SETQ(V1,{VCW,EDGE,FACE})
01500 LAC 1,EDGE
01600 L2: CALL(ECW,1,FACE)↔SOJG M,L2
01700 SETQ(V2,{VCW,1,FACE})
01800 SETQ(EDGE,{MKFE,V2,FACE,V1}) ;CLOSE THE TOP OF THE GAP.
01900
02000 ;FOLLOW DOWN THE GAP.
02100 L3: CALL(ECCW,EDGE,FACE)↔SETQ(V1,{OTHER,1,V1})
02200 CALL(ECW,EDGE,FACE)↔SETQ(V2,{OTHER,1,V2})
02300 SETQ(EDGE,{MKFE,V2,FACE,V1})
02400 SOSLE NN↔GO L3
02500 SETZ↔LAC 1,FACE↔NCNT. 0,1
02600 POP1J
02700 COMMENT .
02800 ⊗---⊗---⊗----⊗---⊗
02900 | GAP | ← POLE CAP
03000 | ↓ |
03100 ⊗-----⊗←←←←⊗-----⊗ ← ARTIC CIRCLE
03200 PED(F)→| |
03300 | |
03400 V1' ⊗←←←←⊗ V2'
03500 | F |
03600 | |
03700 ⊗-----⊗ ⊗-----⊗ ← ANTARTIC CIRCLE.
03800
03900 DECLARE{FACE,EDGE,V1,V2,NN}
04000 BEND;2/8/73-------------------------------------------------------
00100 SUBR(PYRAMID)FACE OR VERTEX---------------------------------------
00200 BEGIN PYRAMID
00300
00400 LAC 1,ARG1↔TEST 1,VBIT↔GO L2
00500 ;VERTEX ARGUMENT - GIVEN THE PEAK FORM THE BASE.
00600 DAC 1,V
00700 PED 2,1↔DAC 2,E0↔DAC 2,E2
00800 SETQ(V2,{OTHER,E2,V})
00900 L1: LAC E2↔DAC E1
01000 LAC V2↔DAC V1
01100 SETQ(E2,{ECCW,E1,V})
01200 SETQ(V2,{OTHER,E2,V})
01300 CALL(LINKED,V1,V2)↔JUMPE 1,[ ;WHEN NOT LINKED.
01400 CALL(FCCW,E1,V)
01500 CALL(MKFE,V1,1,V2)↔GO .+1]
01600 LAC E2↔CAME E0↔GO L1
01700 LAC 1,ARG1↔POP1J
01800 DECLARE{V,V1,V2,E0,E1,E2}
01900
02000 ;FACE ARGUMENT - GIVEN THE BASE FORM THE PEAK.
02100 L2: DAC 1,F↔TEST 1,FBIT↔POP1J
02200 SETZM X↔SETZM Y↔SETZM Z↔SETZM N
02300 PED 2,1↔DAC 2,E↔DAC 2,E0
02400 SETQ(V0,{VCW,E0,F})
02500 SETQ(PEAK,{MKEV,F,V0})
02600 L3: SETQ(V,{VCCW,E,F})
02700 LAC XWC(1)↔FADRM X
02800 LAC YWC(1)↔FADRM Y
02900 LAC ZWC(1)↔FADRM Z
03000 AOS N↔CAMN 1,V0↔GO L4
03100 SETQ(E,{ECCW,E,F})
03200 CALL(MKFE,PEAK,F,V)
03300 GO L3
03400 L4: LAC 1,PEAK↔LAC 2,N↔FLOAT 2,
03500 LAC X↔FDVR 2↔DAC XWC(1)
03600 LAC Y↔FDVR 2↔DAC YWC(1)
03700 LAC Z↔FDVR 2↔DAC ZWC(1)
03800 POP1J
03900 DECLARE{PEAK,F,E,V0,X,Y,Z,N}
04000
04100 BEND;2/8/73-------------------------------------------------------
00100 SUBR(REMOVF)FACE-------------------------------------------------
00200 BEGIN REMOVE; REMOVE A FACE FROM A POLYHEDRON - BGB - 7 FEB 1973.
00300 LAC 1,ARG1↔TEST 1,FBIT↔POP1J↔DAC 1,F
00400 PED 2,1↔DAC 2,E
00500 SETQ(V0,{VCW,E,F})
00600 SETQ(V,{VCCW,E,F})↔SLACI XWC(1)↔LAPI X↔BLT Z
00700 SETQ(A,{ECCW,E,F})
00800 SETQ(F,{KLFE,E})
00900 LACI 1↔DAC N
01000 L1: LAC 1,A↔DAC 1,E
01100 PVT 0,1↔CAMN 0,V↔GO[CALL(INVERT,E)↔GO .+1]
01200 SETQ(A,{ECCW,A,F})
01300 SETQ(V,{KLVE,E})
01400 LAC XWC(1)↔FADRM X
01500 LAC YWC(1)↔FADRM Y
01600 LAC ZWC(1)↔FADRM Z↔AOS N
01700 CAME 1,V0↔GO L1
01800 ;PLACE VERTEX AT CENTER OF DECEASED FACE.
01900 LAC 2,N↔FLOAT 2,
02000 LAC X↔FDVR 2↔DAC XWC(1)
02100 LAC Y↔FDVR 2↔DAC YWC(1)
02200 LAC Z↔FDVR 2↔DAC ZWC(1)
02300 POP1J
02400 DECLARE{F,E,V,V0,A,X,Y,Z,N}
02500 BEND;2/10/73-----------------------------------------------------
00100 SUBR(FVDUAL)BODY-------------------------------------------------
00200 BEGIN FVDUAL; FACE-VERTEX DUAL - BGB - 20 FEBRUARY 1973.
00300 ACCUMULATORS{B,F,E,V,E0,X,Y,Z,I}
00400 LAC B,ARG1↔TEST B,BBIT↔POP1J
00500
00600 ;FOR ALL THE FACES OF THE BODY.
00700 LAC F,B
00800 L1: PFACE F,F↔TEST F,FBIT↔GO L3
00900 SETZB X,Y↔SETZB Z,I
01000 PED E,F↔DAC E,E0
01100
01200 ;COMPUTE CENTER OF EACH FACE.
01300 L2: SETQ(V,{VCCW,E,F})
01400 SETQ(E,{ECCW,E,F})
01500 FADR X,XWC(V)↔FADR Y,YWC(V)↔FADR Z,ZWC(V)
01600 AOS I
01700 CAME E,E0↔GO L2
01800
01900 ;CONVERT FACES INTO VERTICES.
02000 FLOAT I,↔FDVR X,I↔FDVR Y,I↔FDVR Z,I
02100 DAC X,XWC(F)↔DAC Y,YWC(F)↔DAC Z,ZWC(F)
02200 LAC 1(F)↔DAC 3(F)↔SLACI(VBIT)↔DAC(F)
02300 GO L1
02400
02500 ;CONVERT VERTICES INTO FACES.
02600 L3: LAC V,ARG1↔LACI 1,2↔LAC E,ARG1
02700 L4: PVT V,V↔TEST V,VBIT↔GO L5
02800 LAC 3(V)↔DAC 1(V)↔DIP 1,(V)↔GO L4
02900
03000 ;TURN ALL THE EDGES OVER AND INSIDE OUT.
03100 L5: PED E,E↔TEST E,EBIT↔GO L6
03200 LAC 1(E)↔EXCH 3(E)↔DAC 1(E)
03300 MOVSS 1(E)
03400 MOVS 4(E)↔MOVE 1,5(E)
03500 DAC 1,4(E)↔DAC 5(E)
03600 GO L5
03700
03800 L6: LAC B,ARG1↔LAC 1(B)↔EXCH 3(B)↔DAC 1(B)
03900 POP1J
04000 BEND;2/10/73-----------------------------------------------------
00100 SUBR(MKCUBE)DX,DY,DZ --------------------------------------------
00200 BEGIN MKCUBE; MAKE A CUBE WITH SIDES DX, DY, DZ.
00300
00400 SETQ(B,{MKB,[0]})
00500 SETQ(F,{MKF,B})
00600 SETQ(V,{MKV,B})
00700 LAC ARG3↔FSC -1↔DAC XWC(1)
00800 LAC ARG2↔FSC -1↔DAC YWC(1)
00900 LAC ARG1↔FSC -1↔DAC ZWC(1)
01000 CALL(MKEV,F,1)↔MOVNS XWC(1)
01100 CALL(MKEV,F,1)↔MOVNS YWC(1)
01200 CALL(MKEV,F,1)↔MOVNS XWC(1)
01300 CALL(MKFE,V,F,1)
01400 CALL(SWEEP,F,[0])
01500 LAC 1,B
01600 NVT 1,1↔MOVNS ZWC(1)
01700 NVT 1,1↔MOVNS ZWC(1)
01800 NVT 1,1↔MOVNS ZWC(1)
01900 NVT 1,1↔MOVNS ZWC(1)
02000 LAC 1,B↔POP3J
02100 DECLARE{B,F,V}
02200 BEND MKCUBE; 16 MARCH 1973 --------------------------------------
02300
02400
02500 END
02600 EULER.FAI - EOF.